PsL Monthly 1993 December/PSL Monthly Shareware CD-ROM (December 1993).iso/prgmming/dos/pascal/gwedit.com/GWEDIT.PAS

Pascal/Delphi Source File | 1989-03-16 | 12.6 KB | 460 lines

{Line editor and keyboard input routines}
{Inputs a line similar to Readln, but for graphics}
{released to the public domain 3/16/89 by author Michael Day}
{for mouse support, enable the mouse unit in the uses statement}
{and uncomment the mouse statements in GCKeyBoxFlash}

unit GwEdit;

interface

uses
   Dos,
   crt,       {<- you can use crt, or your own favorite crt unit}
   KeyCodes,          {only needed for "KeyPressed" and "ReadKey"}
   AreaWr,
   GwCurse,
{   Mouse, }
   GStart;

const
  {- the following controls how ReadString operates -}
  ForceUpper:boolean = false;    {force chars to uppercase?}
  InsertDefault:boolean = true;  {default to insert mode?}
  ClearFirstChar:boolean = true; {clr string if 1st char entered is ASCII}
  EscapeRestore:boolean = false; {restore old data when escape pressed}


var GwChar:char;        {char/scan code for last keyboard entry}
    TfddChar:char;

{-------------------------------------------------------------------------}
{Passes a string to be edited to the function and waits for an exit char}
{and exit char is any char that is not a part of the edit sequence.}
{The exit char is passed back to the caller as the function result.}
{X,Y defines where on the screen the text field is located. 'Wide' }
{specifies how wide in characters the field is. 'CPos' is the starting}
{position of the cursor. If 'Edit' is false, then the string is not
{editable the function just waits for a non-edit character to return}
{to the caller. This is useful for database fields where a field needs}
{to be displayed but editing needs to be inhibited. 'Color' sets the}
{drawing color of the text field. 'S' is the string that is passed.}

function GwRead(X,Y,Wide,CPos:integer;
                Edit:boolean;
                Color:ColorRec;
                var S:string):char;

procedure AssignGwCrt(var F:Text;
                      X,Y,Wide,CPos:integer;
                      Edit:boolean;
                      Color:ColorRec;
                      var S:string);

{ *********************************************************************** }

implementation

{-flash graphic cursor until key pressed -}
procedure GCKeyBoxFlash(var Ch:char);
var X,Y:word;
begin
  while not(KeyPressed) { and not(MouseClick) } do
    GcursorFlash;
  GcursorOff;
  if KeyPressed then
  begin
    Ch := ReadKey;
    if (Ch = #0) and KeyPressed then
      Ch := char(byte(ReadKey) or $80);
  end
  else
  begin
{    Ch := char(256 - byte(Mouse_Click_Button)); }
  end;
end;


{- Get a string -}
function GwRead(X,Y,Wide,CPos:integer;
                Edit:boolean;
                Color:ColorRec;
                var S:string):char;
var
    Ch : char absolute GwChar;
    St : string;
    StLen : byte absolute St;
    Sp : byte;
    DelEnd : byte;
    MaxLen : integer;
    Inserting : boolean;
    FirstChar : boolean;
    Done : boolean;
    Area : rect;

  {- Toggle between insert and overtype mode}
  procedure ToggleInsertMode;
  begin
     if Edit then
     begin
       Inserting := not(Inserting);  {toggle insert flag}
       if Inserting then
          GcursorType(BlockGcursor)    {use block cursor if inserting}
       else
          GcursorType(NormalGcursor);
     end
     else
     begin
        GcursorType(HiddenGcursor);   {if Edit disabled don't show cursor}
     end;
  end;

  {- Restore default string -}
  procedure GwDefault;
  begin
    St := S;
    if StLen > MaxLen then StLen := MaxLen;
    Sp := CPos;
  end;

  {-Draw the string -}
  procedure DrawString;
  begin
    FillChar(St[Succ(StLen)], MaxLen-StLen, ' '); {Pad with blanks}
    AreaWrite(St,Area,Color);
  end;

{-- procedure ReadString --}
begin
    SetRect(Area,X,Y,X+(Wide*BoxTextWidth),Y+BoxTextHeight);
    SetGcursorPos(Area,Wide,1,Color,MaxLen);
    if MaxLen > Wide then MaxLen := Wide;
    GwDefault;
    GwRead := #0;
    FirstChar := True;

    {- default to insert mode on if InsertDefault is true -}
    Inserting := not(InsertDefault);
    ToggleInsertMode;

    DrawString;

    {- Loop reading keys -}
    Done := False;
    repeat
      {- position cursor and wait for input -}
      if Sp > MaxLen then Sp := MaxLen;
      if Sp < 1 then Sp := 1;
      SetGcursorPos(Area,Wide,Sp,Color,MaxLen);
      if MaxLen > Wide then MaxLen := Wide;
      GCKeyBoxFlash(GwChar);
      if ForceUpper then Ch := Upcase(Ch);
      GwRead := GwChar;

      {- if first key is a character, clear the input string -}
      if ClearFirstChar and FirstChar and Edit then
      begin
        FirstChar := False;
        if (GwChar > #31) and (GwChar < #127) then
        begin
          StLen := 0;
          Sp := 1;
          DrawString;
        end;
      end;

      case GwChar of

        #32..#126:             {A character to enter in the string}
          begin
            if Edit then
            begin
              if not(Inserting) or (Sp > StLen) then
              begin
                if Sp > StLen then StLen := Sp;  {overtype mode}
                St[Sp] := Ch;
                AreaCharWrite(St[Sp],Area,Color,Sp,Wide);
                Inc(Sp);
              end
              else
              begin
                if StLen < MaxLen then   {insert mode}
                begin
                  Insert(Ch, St, Sp);
                  DrawString;
                  Inc(Sp);
                end;
              end;
            end;
         end;

        RetKey :            {Accept current string and quit}
          Done := True;

        EscKey :             {Restore default string and quit}
          begin
            if EscapeRestore then GwDefault;
            Done := True;
          end;

        HomeKey :             {Cursor to begin of line}
          Sp := 1;

        EndKey :              {Cursor to end of line}
          Sp := Succ(StLen);

        CtrlEnd :           {Delete from cursor to end of line}
          begin
            if Edit then
            begin
              St := Copy(St, 1, Pred(Sp));
              DrawString;
            end;
          end;

        CtrlHome :           {Delete from beginning of line to the cursor}
          begin
            if Edit then
            begin
              Delete(St, 1, Pred(Sp));
              Sp := 1;
              DrawString;
            end;
          end;

        GwDelLine :          {Delete entire line}
          begin
            if Edit then
            begin
              StLen := 0;
              Sp := 1;
              DrawString;
            end;
          end;

        GwRestore :          {Restore default and continue}
          begin
            GwDefault;
            DrawString;
          end;

        GwLeft,LeftArrow :             {Cursor left by one character}
          if Sp > 1 then Dec(Sp);

        GwRight,RightArrow :            {Cursor right by one character}
          if Sp <= StLen then Inc(Sp);

        GwWordLeft,CtrlLeft :         {Cursor left one word}
          if Sp > 1 then
          begin
            Dec(Sp);
            while (Sp >= 1) and ((Sp > StLen) or (St[Sp] = ' ')) do Dec(Sp);
            while (Sp >= 1) and (St[Sp] <> ' ') do Dec(Sp);
            Inc(Sp);
          end;

        GwWordRight,CtrlRight :        {Cursor right one word}
          if Sp <= StLen then
          begin
            Inc(Sp);
            while (Sp <= StLen) and (St[Sp] <> ' ') do Inc(Sp);
            while (Sp <= StLen) and (St[Sp] = ' ') do Inc(Sp);
          end;

        GwDelChar,DelKey :              {Delete current character}
          begin
            if Edit then
            begin
              if Sp < StLen then
              begin
                Delete(St, Sp, 1);
                DrawString;
              end
              else
              begin
                if Sp = StLen then
                begin
                  St[Sp] := ' ';
                  AreaCharWrite(St[Sp],Area,Color,Sp,Wide);
                  StLen := pred(Sp);
                end;
              end;
            end;
          end;

        BackSpace,GwRub :             {Backspace one character}
          if Sp > 1 then
          begin
            Dec(Sp);
            if Edit then
            begin
              if Sp = StLen then
              begin
                St[Sp] := ' ';
                AreaCharWrite(St[Sp],Area,Color,Sp,Wide);
                StLen := pred(Sp);
              end
              else
              begin
                Delete(St, Sp, 1);
                DrawString;
              end;
            end;
          end;

        GwDelWord :          {Delete word to right of cursor}
          if (Sp <= StLen) and Edit then
          begin
            DelEnd := Sp;
            while (St[DelEnd] <> ' ') and (DelEnd <= StLen) do Inc(DelEnd);
            while (St[DelEnd] = ' ') and (DelEnd <= StLen) do Inc(DelEnd);
            Delete(St, Sp, DelEnd-Sp);
            DrawString;
          end;

        InsKey :              {Toggle insert mode}
          if Edit then
            ToggleInsertMode;

        else             {Accept current string and quit}
          begin
            Done := True;
          end;
      end; {case}

    until Done;

    DrawString;               {redraw the string one last time}
    S := St;                  {update return string}
end;





{ -********************************************************************** -}
{                                                                          }
{-  The following are the procedures which allows GwEdit to use a TFDD    -}
{                                                                          }
{ -********************************************************************** -}


type TfddGwRec = record
       GwX,GwY : integer;
       GwWide  : byte;
       GwCPos  : byte;
       GwEdit  : boolean;
       GwColor : ColorRec;
       GwSPtr  : ^String;
       Unused  : byte;
     end;

{limit value to text buffer size-2 }
function TLimit(Value:integer):byte;
begin
  if Value > 126 then TLimit := 126
  else
    if Value < 1 then TLimit := 1
    else
      TLimit := Value;
end;



{$F+}   { force fall calls for TFDD }

{++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{-- Ignore this function call --}
function TfddIgnore(var F:TextRec):integer;
begin
   TfddIgnore := 0;
end;

{- write string to screen using Gw params -}
function TfddGwWrite(var F:TextRec):integer;
var Area:rect;
begin
   with F,TfddGwRec(UserData) do
   begin
     move(BufPtr^,GwSPtr^[1],BufPos);
     GwSPtr^[0] := char(BufPos);
     SetRect(Area,GwX,GwY,GwX+(GwWide*BoxTextWidth),GwY+BoxTextHeight);
     AreaWrite(GwSPtr^,Area,GwColor);
     BufPos := 0;
   end;
   TfddGwWrite := 0;
end;

{- write string to screen and wait for editing to be complete -}
function TfddGwRead(var F:TextRec):integer;
begin
   with F,TfddGwRec(UserData) do
   begin
     TfddChar := GwRead(GwX,GwY,GwWide,GwCPos,GwEdit,GwColor,GwSPtr^);
     if GwSPtr^[0] > #0 then
       move(GwSPtr^[1],BufPtr^,TLimit(integer(GwSPtr^[0])));
     BufPtr^[integer(GwSPtr^[0])] := #13;
     BufPtr^[succ(integer(GwSPtr^[0]))] := #10;
     BufEnd := integer(GwSPtr^[0])+2;
     BufPos := 0;
   end;
   TfddGwRead := 0;
end;

{- Open the screen for Gw read/write -}
function TfddGwOpen(var F:TextRec):integer;
begin
  with F do
  begin
    if Mode=fmInput then
    begin
      FlushFunc := @TfddIgnore;
      InOutFunc := @TfddGwRead;
    end
    else
    begin
      Mode := fmOutput;
      InOutFunc := @TfddGwWrite;
      FlushFunc := @TfddGwWrite;
    end;
    CloseFunc := @TfddIgnore;
    TfddGwOpen := 0;
  end;
end;

{$F-}  { finished with the local TFDD so return world to normal }

procedure AssignGwCrt(var F:Text;
                      X,Y,Wide,CPos:integer;
                      Edit:boolean;
                      Color:ColorRec;
                      var S:string);

begin
   with TextRec(F) do
   begin
     Handle := $FFFF;
     Mode := fmClosed;
     BufSize := SizeOf(Buffer);
     BufPtr := @Buffer;
     OpenFunc := @TfddGwOpen;
     CloseFunc := @TfddIgnore;
     Name[0] := #0;

     TfddGwRec(UserData).GwX := X;
     TfddGwRec(UserData).GwY := Y;
     TfddGwRec(UserData).GwWide := TLimit(Wide);
     TfddGwRec(UserData).GwCPos := TLimit(CPos);
     TfddGwRec(UserData).GwEdit := Edit;
     TfddGwRec(UserData).GwColor := Color;
     TfddGwRec(UserData).GwSPtr := @S;

   end;
end;

{ ********************************************************************** }

end.